home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 1 / Gold Medal Software Volume 1 (Gold Medal) (1994).iso / prog / tpwprog7.arj / UPRINT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-07-02  |  3.8 KB  |  143 lines
  1. { uprint.pas -- Printer support unit for text and graphics }
  2.  
  3. unit UPrint;
  4.  
  5. interface
  6.  
  7. uses WinTypes, WinProcs, WObjects, Strings;
  8.  
  9. function NextToken(P: PChar; C: Char): PChar;
  10. function PrnStart(DocumentName: PChar): Boolean;
  11. procedure NewPage;
  12. procedure PrnLine(P: PChar);
  13. procedure PrnStop;
  14.  
  15. var
  16.  
  17.   PDc: HDC;              { Printer's DC: valid if PrnStart = true }
  18.  
  19. implementation
  20.  
  21. const
  22.  
  23.   LeftMargin = 10;       { Width of page's left margin }
  24.   LinesAtTop = 3;        { Number of lines in page's top margin }
  25.   LinesAtBottom = 3;     { Number of lines in page's bottom margin }
  26.   MinimumLines = LinesAtTop + LinesAtBottom + 1;
  27.  
  28. var
  29.  
  30.   Printing: Boolean;     { True after successful call to PrnStart }
  31.   EscResult: Integer;    { Result of most recent call to Escape }
  32.   LineHeight: Integer;   { Height of each line in printer units }
  33.   CurrentLine: Integer;  { Line number on page. 0 = at top of page }
  34.   LinesPerPage: Integer; { Maximum number of lines printed per page }
  35.  
  36.  
  37. {- Return pointer to next token in P or previous P if P = nil }
  38. function NextToken(P: PChar; C: Char): PChar;
  39. const
  40.   Next: PChar = nil;
  41. begin
  42.   if P = nil then P := Next;
  43.   Next := StrScan(P, C);
  44.   if Next <> nil then
  45.   begin
  46.     Next^ := #0;
  47.     Next := @Next[1]
  48.   end;
  49.   NextToken := P
  50. end;
  51.  
  52. {- Initialize global printing parameters }
  53. procedure InitPrintParams;
  54. var
  55.   TM: TTextMetric;
  56.   PageWidth, PageHeight: Integer;
  57. begin
  58.   GetTextMetrics(PDc, TM);
  59.   PageWidth := GetDeviceCaps(PDc, HorzRes); { Not used }
  60.   PageHeight := GetDeviceCaps(PDc, VertRes);
  61.   LineHeight := TM.tmHeight + TM.tmHeight div 2;
  62.   if LineHeight <= 0 then
  63.     LineHeight := 10;  { Prevent divide by zero error }
  64.   LinesPerPage := PageHeight div LineHeight;
  65.   if LinesPerPage < MinimumLines then
  66.     LinesPerPage := MinimumLines;
  67.   CurrentLine := LinesAtTop
  68. end;
  69.  
  70.  
  71. { Global routines }
  72.  
  73. {- If true, text may be printed by calling PrnLine. }
  74. function PrnStart(DocumentName: PChar): Boolean;
  75. var
  76.   Buffer: array[0 .. 80] of Char;
  77.   DriverName, DeviceName, OutputName: PChar;
  78. begin
  79.   GetProfileString('windows', 'device', ',,', Buffer, Sizeof(Buffer));
  80.   DeviceName := NextToken(Buffer, ',');
  81.   DriverName := NextToken(nil, ',');
  82.   OutputName := NextToken(nil, ',');
  83.   PDc := CreateDC(DriverName, DeviceName, OutputName, nil);
  84.   if PDc <> 0 then
  85.   begin
  86.     EscResult := Escape(PDc, StartDoc, StrLen(DocumentName),
  87.       DocumentName, nil);
  88.     Printing := EscResult > 0
  89.   end else
  90.     Printing := false;
  91.   if Printing then
  92.   begin
  93.     SetCursor(LoadCursor(0, idc_Wait));
  94.     InitPrintParams
  95.   end else
  96.     MessageBox(Application^.MainWindow^.HWindow,
  97.       'Printer initialization failed', 'Error',
  98.       mb_IconExclamation or mb_Ok);
  99.   PrnStart := Printing
  100. end;
  101.  
  102. {- Print current page and start a new one }
  103. procedure NewPage;
  104. begin
  105.   if Printing and (EscResult > 0) then
  106.   begin
  107.     EscResult := Escape(PDc, NewFrame, 0, nil, nil);
  108.     CurrentLine := LinesAtTop
  109.   end
  110. end;
  111.  
  112. {- Print one line addressed by P }
  113. procedure PrnLine(P: PChar);
  114. begin
  115.   Inc(CurrentLine);
  116.   TextOut(PDc, LeftMargin, CurrentLine * LineHeight, P, StrLen(P));
  117.   if CurrentLine >= LinesPerPage - LinesAtBottom then
  118.     NewPage
  119. end;
  120.  
  121. {- Call only if PrnStop returned true. }
  122. procedure PrnStop;
  123. begin
  124.   if Printing then
  125.   begin
  126.     if CurrentLine > LinesAtTop then
  127.       NewPage;  { Print last partial page }
  128.     if EscResult > 0 then
  129.       Escape(PDc, EndDoc, 0, nil, nil);
  130.     SetCursor(LoadCursor(0, idc_Arrow));
  131.     DeleteDC(PDc);
  132.     Printing := false
  133.   end
  134. end;
  135.  
  136. end.
  137.  
  138.  
  139. {--------------------------------------------------------------
  140.   Copyright (c) 1991 by Tom Swan. All rights reserved.
  141.   Revision 1.00    Date: 5/16/1991
  142. ---------------------------------------------------------------}
  143.